home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / gtmous13.zip / TVBDEMO.PAS < prev   
Pascal/Delphi Source File  |  1993-06-28  |  8KB  |  326 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal 6.0                             }
  4. {   Demo program from the Turbo Vision Guide     }
  5. {   Copyright (c) 1990 by Borland International  }
  6. {                                                }
  7. {   TVBeauty 1.0                                 }
  8. {   Changes Copyright (c) 1992 by Igor I. Evsikov}
  9. {   Sergey Yu. Shmakov &  Pete P. Sychov         }
  10. {************************************************}
  11. program TVBDEMO;
  12.  
  13. uses GTMOUSE,Objects, Drivers, Views, Menus, Dialogs, App, Memory, Dos;
  14.  
  15. const
  16.   FileToRead        = 'TVBDEMO.PAS';
  17.   MaxLines          = 100;
  18.   WinCount: Integer =   0;
  19.   cmFileOpen        = 100;
  20.   cmNewWin          = 101;
  21.   cmNewDialog       = 102;
  22.   cmChIm            = 103;
  23.   cmdosshell        = 104;
  24. var
  25.   LineCount: Integer;
  26.   Lines: array[0..MaxLines - 1] of PString;
  27.  
  28. type
  29.   TMyApp = object(TApplication)
  30.     procedure HandleEvent(var Event: TEvent); virtual;
  31.     procedure InitMenuBar; virtual;
  32.     procedure InitStatusLine; virtual;
  33.     procedure NewDialog;
  34.     procedure NewWindow;
  35.     procedure dosshell;
  36.     procedure idle;virtual;
  37.   end;
  38.  
  39.  
  40.   PInterior = ^TInterior;
  41.   TInterior = object(TScroller)
  42.     constructor Init(var Bounds: TRect; AHScrollBar,
  43.       AVScrollBar: PScrollBar);
  44.     procedure Draw; virtual;
  45.   end;
  46.  
  47.   PDemoWindow = ^TDemoWindow;
  48.   TDemoWindow = object(TWindow)
  49.     RInterior, LInterior: PInterior;
  50.     constructor Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  51.     function MakeInterior(Bounds: TRect; Left: Boolean): PInterior;
  52.     procedure SizeLimits(var Min, Max: TPoint); virtual;
  53.   end;
  54.  
  55.   PDemoDialog = ^TDemoDialog;
  56.   TDemoDialog = object(TDialog)
  57.   end;
  58.  
  59.  
  60. procedure TMyApp.idle;
  61. begin
  62.   TApplication.idle;
  63. {  DrawArrow;}
  64. end;
  65.  
  66. procedure Tmyapp.DosShell;
  67. begin
  68.   DoneSysError;
  69.   DoneEvents;
  70.   DoneVideo;
  71.   DoneMemory;
  72.   SetMemTop(HeapPtr);
  73.   PrintStr('Type EXIT to return...');
  74.  
  75.   DoneGTMouse;
  76.   RestoreFont;
  77.  
  78.   SwapVectors;
  79.   Exec(GetEnv('COMSPEC'), '');
  80.   SwapVectors;
  81.  
  82.   SetFont;
  83.   InitGtMouse;
  84.  
  85.   SetMemTop(HeapEnd);
  86.   InitGtMouse;
  87.   InitMemory;
  88.   InitVideo;
  89.   InitEvents;
  90.   InitSysError;
  91.   Redraw;
  92. end;
  93.  
  94. procedure ReadFile;
  95. var
  96.   F: Text;
  97.   S: String;
  98. begin
  99.   LineCount := 0;
  100.   Assign(F, FileToRead);
  101.   {$I-}
  102.   Reset(F);
  103.   {$I+}
  104.   if IOResult <> 0 then
  105.   begin
  106.     Writeln('Cannot open ', FileToRead);
  107.     Halt(1);
  108.   end;
  109.   while not Eof(F) and (LineCount < MaxLines) do
  110.   begin
  111.     Readln(F, S);
  112.     Lines[LineCount] := NewStr(S);
  113.     Inc(LineCount);
  114.   end;
  115.   Close(F);
  116. end;
  117. procedure NewImage;
  118. begin
  119.  inc(ImageNoPressed);
  120.  if ImageNoPressed=DragArrow then inc(ImageNoPressed);
  121.  if ImageNoPressed=UserArrow then ImageNoPressed:=NormalArrow;
  122. end;
  123.  
  124. procedure DoneFile;
  125. var
  126.   I: Integer;
  127. begin
  128.   for I := 0 to LineCount - 1 do
  129.     if Lines[I] <> nil then DisposeStr(Lines[i]);
  130. end;
  131.  
  132. { TInterior }
  133. constructor TInterior.Init(var Bounds: TRect; AHScrollBar,
  134.   AVScrollBar: PScrollBar);
  135. begin
  136.   TScroller.Init(Bounds, AHScrollBar, AVScrollBar);
  137.   Options := Options or ofFramed;
  138.   SetLimit(128, LineCount);
  139. end;
  140.  
  141. procedure TInterior.Draw;
  142. var
  143.   Color: Byte;
  144.   I, Y: Integer;
  145.   B: TDrawBuffer;
  146. begin
  147.   Color := GetColor(1);
  148.   for Y := 0 to Size.Y - 1 do
  149.   begin
  150.     MoveChar(B, ' ', Color, Size.X);
  151.     i := Delta.Y + Y;
  152.     if (I < LineCount) and (Lines[I] <> nil) then
  153.       MoveStr(B, Copy(Lines[I]^, Delta.X + 1, Size.X), Color);
  154.     WriteLine(0, Y, Size.X, 1, B);
  155.   end;
  156. end;
  157.  
  158. { TDemoWindow }
  159. constructor TDemoWindow.Init(Bounds: TRect; WinTitle: String; WindowNo: Word);
  160. var
  161.   S: string[3];
  162.   R: TRect;
  163. begin
  164.   Str(WindowNo, S);
  165.   TWindow.Init(Bounds, WinTitle + ' ' + S, wnNoNumber);
  166.   GetExtent(Bounds);
  167.   R.Assign(Bounds.A.X, Bounds.A.Y, Bounds.B.X div 2 + 1, Bounds.B.Y);
  168.   LInterior := MakeInterior(R, True);
  169.   LInterior^.GrowMode := gfGrowHiY;
  170.   Insert(Linterior);
  171.   R.Assign(Bounds.B.X div 2, Bounds.A.Y, Bounds.B.X, Bounds.B.Y);
  172.   RInterior := MakeInterior(R,False);
  173.   RInterior^.GrowMode := gfGrowHiX + gfGrowHiY;
  174.   Insert(RInterior);
  175. end;
  176.  
  177. function TDemoWindow.MakeInterior(Bounds: TRect; Left: Boolean): PInterior;
  178. var
  179.   HScrollBar, VScrollBar: PScrollBar;
  180.   R: TRect;
  181. begin
  182.   R.Assign(Bounds.B.X-1, Bounds.A.Y+1, Bounds.B.X, Bounds.B.Y-1);
  183.   VScrollBar := New(PScrollBar, Init(R));
  184.   VScrollBar^.Options := VScrollBar^.Options or ofPostProcess;
  185.   if Left then VScrollBar^.GrowMode := gfGrowHiY;
  186.   Insert(VScrollBar);
  187.   R.Assign(Bounds.A.X+2, Bounds.B.Y-1, Bounds.B.X-2, Bounds.B.Y);
  188.   HScrollBar := New(PScrollBar, Init(R));
  189.   HScrollBar^.Options := HScrollBar^.Options or ofPostProcess;
  190.   if Left then HScrollBar^.GrowMode := gfGrowHiY + gfGrowLoY;
  191.   Insert(HScrollBar);
  192.   Bounds.Grow(-1,-1);
  193.   MakeInterior := New(PInterior, Init(Bounds, HScrollBar, VScrollBar));
  194. end;
  195.  
  196. procedure TDemoWindow.SizeLimits(var Min, Max: TPoint);
  197. var R: TRect;
  198. begin
  199.   TWindow.SizeLimits(Min, Max);
  200.   Min.X := LInterior^.Size.X + 9;
  201. end;
  202.  
  203. { TMyApp }
  204. procedure TMyApp.HandleEvent(var Event: TEvent);
  205. begin
  206.   TApplication.HandleEvent(Event);
  207.   if Event.What = evCommand then
  208.   begin
  209.     case Event.Command of
  210.       cmNewWin: NewWindow;
  211.       cmNewDialog: NewDialog;
  212.       cmChIm: NewImage;
  213.       cmDosshell:dosshell;
  214.     else
  215.       Exit;
  216.     end;
  217.     ClearEvent(Event);
  218.   end;
  219. end;
  220.  
  221. procedure TMyApp.InitMenuBar;
  222. var R: TRect;
  223. begin
  224.   GetExtent(R);
  225.   R.B.Y := R.A.Y + 1;
  226.   MenuBar := New(PMenuBar, Init(R, NewMenu(
  227.     NewSubMenu('~F~ile', hcNoContext, NewMenu(
  228.       NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
  229.       NewItem('~D~os shell', 'alt F4', kbaltF4, cmdosshell, hcNoContext,
  230.       NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
  231.       NewLine(
  232.       NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  233.       nil)))))),
  234.     NewSubMenu('~W~indow', hcNoContext, NewMenu(
  235.       NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
  236.       NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
  237.       NewItem('~D~ialog', 'F2', kbF2, cmNewDialog, hcNoContext,
  238.       nil)))),
  239.     nil))
  240.   )));
  241. end;
  242.  
  243. procedure TMyApp.InitStatusLine;
  244. var R: TRect;
  245. begin
  246.   GetExtent(R);
  247.   R.A.Y := R.B.Y - 1;
  248.   StatusLine := New(PStatusLine, Init(R,
  249.     NewStatusDef(0, $FFFF,
  250.       NewStatusKey('', kbF10, cmMenu,
  251.       NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
  252.       NewStatusKey('~F4~ New', kbF4, cmNewWin,
  253.       NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
  254.       NewStatusKey('~Alt-H~ cHange image', kbAltH, cmChIm,
  255.       nil))))),
  256.     nil)
  257.   ));
  258. end;
  259.  
  260. procedure TMyApp.NewDialog;
  261. var
  262.   Bruce: PView;
  263.   Dialog: PDemoDialog;
  264.   R: TRect;
  265.   C: Word;
  266. begin
  267.   R.Assign(20, 6, 60, 19);
  268.   Dialog := New(PDemoDialog, Init(R, 'Demo Dialog'));
  269.   with Dialog^ do
  270.   begin
  271.     R.Assign(3, 3, 18, 6);
  272.     Bruce := New(PCheckBoxes, Init(R,
  273.       NewSItem('~H~varti',
  274.       NewSItem('~T~ilset',
  275.       NewSItem('~J~arlsberg',
  276.       nil)))
  277.     ));
  278.     Insert(Bruce);
  279.     R.Assign(2, 2, 10, 3);
  280.     Insert(New(PLabel, Init(R, 'Cheeses', Bruce)));
  281.     R.Assign(22, 3, 34, 6);
  282.     Bruce := New(PRadioButtons, Init(R,
  283.       NewSItem('~S~olid',
  284.       NewSItem('~R~unny',
  285.       NewSItem('~M~elted',
  286.       nil)))
  287.     ));
  288.     Insert(Bruce);
  289.     R.Assign(21, 2, 33, 3);
  290.     Insert(New(PLabel, Init(R, 'Consistency', Bruce)));
  291.     R.Assign(15, 10, 25, 12);
  292.     Insert(New(PButton, Init(R, '~O~k', cmOK, bfDefault)));
  293.     R.Assign(28, 10, 38, 12);
  294.     Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  295.   end;
  296.   C := DeskTop^.ExecView(Dialog);
  297.   Dispose(Dialog, Done);
  298. end;
  299.  
  300. procedure TMyApp.NewWindow;
  301. var
  302.   Window: PDemoWindow;
  303.   R: TRect;
  304. begin
  305.   Inc(WinCount);
  306.   R.Assign(0, 0, 45, 13);
  307.   R.Move(Random(34), Random(11));
  308.   Window := New(PDemoWindow, Init(R, 'Demo Window', WinCount));
  309.   DeskTop^.Insert(Window);
  310. end;
  311.  
  312. var
  313.   MyApp: TMyApp;
  314.   i : integer;
  315.          CONST newarray : Array[1..8] of Char =
  316.                                    (^A,^B,^C,^T,'╠','═','╬','╧');
  317. begin
  318.   InitSleepper(10,80,1,80,1); { ReInit Slepper to left down}
  319.   setNewCharacters(newarray);
  320.   ReadFile;
  321.   MyApp.Init;
  322.   MyApp.Run;
  323.   MyApp.Done;
  324.   DoneFile;
  325. end.
  326.